Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/polygo/polygone.bas

BASIC Source File | 1995-05-09 | 20.1 KB | 738 lines

   DefSng A-Z

   Option Explicit

   Declare Function GetPrivateProfileString% Lib "Kernel" (ByVal section$, ByVal keyname$, ByVal default$, ByVal buff$, ByVal nSize%, ByVal fil$)
   Declare Function WritePrivateProfileString% Lib "Kernel" (ByVal section$, ByVal keyname$, ByVal valu$, ByVal fil$)

   Global Const TwoPi! = 6.283185
   Global Const nSq = 27    'number of erase rectangles per height/width
   Global Const nSq2 = (nSq * nSq) - 1
   Global SqNum(0 To nSq2) As Integer

   Global Ratio As Single
   Global ScreenHeight As Single
   Global ScreenWidth As Single
   Global NominalSize As Single
   Global CLSFlag As Integer
   Global LargestAllowed As Integer
   Global SmallestAllowed As Integer
   Global OnScreenCount As Integer

   Global ThickOrder As Integer
   Global DrawInOrder As Integer
   Global DrawDelay As Long
   Global DrawSpeed As Long

   Global Sparkles As Integer
   Global EraseInit As Integer
   Global EraseOptions(0 To 7) As Integer
   Global EraseMinInterval As Integer
   Global EraseMaxInterval As Integer

Sub DrawPoly (Order%, H, V, Size)

   Dim k2, k3, x, y, x1, y1
   Dim p As Integer
   Dim i As Integer
   Dim j As Integer
   Dim D As Long

   k2 = TwoPi / Order
   ReDim IAry(0 To Order - 1) As Integer
   Shuffle IAry(), DrawInOrder
   For p = 0 To Order - 1
      i = IAry(p)
      k3 = k2 * i
      x = (Size * Sin(k3) * Ratio) + H
      y = (Size * Cos(k3)) + V
      '
      ' Draw the vertex connections alternately
      ' clockwise and counterclockwise, on a
      ' random basis.
      '
      If Rnd > .5 Then    ' about half the time
         For j = i + 1 To Order - 1
            GoSub InnerLoop
         Next j
      Else
         For j = Order - 1 To i + 1 Step -1
            GoSub InnerLoop
         Next j
      End If
   Next
   Exit Sub

InnerLoop:
   k3 = k2 * j
   x1 = (Size * Sin(k3)) * Ratio + H
   y1 = (Size * Cos(k3)) + V
   PolyForm.Line (x, y)-(x1, y1)
   If DrawSpeed > 0 Then
      For D& = 1 To DrawSpeed
         DoEvents
      Next
   Else
      DoEvents
   End If
   Return

End Sub

Sub EraseForm ()

   Dim H As Single
   Dim V As Single

   Dim k As Integer
   Dim j As Integer
   Dim k2 As Integer
   Dim Ctr As Integer
   Dim iLim As Integer
   Dim iLimCtr As Integer

   Static SqHgt As Integer
   Static SqWid As Integer
   Static Bumps(1 To 4)  As Integer

   If EraseInit Then                ' the first time after a resize
      SqHgt = ScreenHeight \ nSq    ' calculate the size of a single square
      SqWid = ScreenWidth \ nSq
      Do
         Shuffle SqNum(), False
      Loop Until SqNum(3) <> 3
                           ' spiral directions
      Bumps(1) = -1                 ' N
      Bumps(2) = -nSq               ' W
      Bumps(3) = 1                  ' E
      Bumps(4) = nSq                ' S

      EraseInit = 0                 ' clear flag until next resize
   End If

   k2 = UBound(EraseOptions) + 1
   Do    ' pick an erase style from the enabled options
      k = Int(Rnd * k2)
   Loop Until EraseOptions(k) <> 0

   Select Case k
   Case 0      ' snap
      k = k
      'do nothing
   Case 1      ' Random
      For k = 0 To nSq2
         j = SqNum(k)
         GoSub DrawBox
      Next
   Case 2      ' HSnake
      For k = 0 To nSq - 1
         If (k And 1) Then
            For k2 = 0 To nSq - 1
               j = k + (k2 * nSq)
               GoSub DrawBox
            Next
         Else
            For k2 = nSq - 1 To 0 Step -1
               j = k + (k2 * nSq)
               GoSub DrawBox
            Next
         End If
      Next
   Case 3      ' VSnake
      For k = 0 To nSq - 1
         If (k And 1) Then
            For k2 = 0 To nSq - 1
               j = k2 + (k * nSq)
               GoSub DrawBox
            Next
         Else
            For k2 = nSq - 1 To 0 Step -1
               j = k2 + (k * nSq)
               GoSub DrawBox
            Next
         End If
      Next
   Case 4   ' SpiralOut
      Ctr = nSq2 + 1             ' total squares
      k2 = 0                     ' direction, N/W/S/E
      iLim = 0                   ' move limit, 1 to nSq
      iLimCtr = 0                ' counter for moves
      j = Ctr \ 2                ' initial square = center
      For k = 1 To Ctr           ' for each square "j"
         GoSub DrawBox           ' erase square
         If iLimCtr = 0 Then     ' if reached limit in this dir'n
            If (k2 And 1) = 0 Then ' if N or S then
               iLim = iLim + 1   ' increase limit
            End If
            iLimCtr = iLim       ' refresh counter
            k2 = k2 + 1          ' change directions
            If k2 > 4 Then       ' if changed too far
               k2 = 1            ' reset to N
            End If
         End If
         iLimCtr = iLimCtr - 1   ' count this move
         j = j + Bumps(k2)       ' and select next square
      Next

   Case 5   ' SpiralIn
      Ctr = nSq2 + 1             ' total squares
      k2 = 3                     ' direction, N/W/S/E
      iLim = nSq                 ' move limit, 1 to nSq
      iLimCtr = nSq - 1          ' counter for moves
      j = 0                      ' initial square = corner
      For k = 1 To Ctr           ' for each square "j"
         GoSub DrawBox           ' erase square
         If iLimCtr = 0 Then     ' if reached limit in this dir'n
            If (k2 And 1) = 1 Then ' if N or S then
               iLim = iLim - 1   ' increase limit
            End If
            iLimCtr = iLim       ' refresh counter
            k2 = k2 + 1          ' change directions
            If k2 > 4 Then       ' if changed too far
               k2 = 1            ' reset to N
            End If
         End If
         iLimCtr = iLimCtr - 1   ' count this move
         j = j + Bumps(k2)       ' and select next square
      Next

   Case 6      ' Zigzag walk
      iLimCtr = 2
      Ctr = nSq2 + 1
      j = Int(Rnd * nSq2)
      Do
         Do
            k2 = Int(Rnd * 6)
            Select Case k2
            Case 0
               k2 = (nSq - 1)
            Case 1
               k2 = -(nSq - 1)
            Case 2
               k2 = (nSq + 1)
            Case 3
               k2 = -(nSq + 1)
            Case 4
               'k2 = -1
               k2 = -(nSq + 2)
            Case 5
               'k2 = -nSq
               k2 = (nSq - 2)
            'Case 6
               'k2 = 1
            'Case 7
               'k2 = nSq
            End Select
         Loop Until Abs(k2) <> Abs(iLimCtr)
         iLimCtr = k2

         iLim = Int(Rnd * nSq) + 1
         For k = 1 To iLim
            GoSub DrawBox
            j = j + k2
            If j > nSq2 Then
               j = j - nSq2
            ElseIf j < 0 Then
               j = j + nSq2
            End If
         Next
         Ctr = Ctr - (iLim \ 2)
      Loop While Ctr > 0

   Case 7   ' Big Polygon Sweep
      If PolyForm.WindowState = 1 Then
         k = 20
      Else
         k = 84
      End If
      PolyForm.DrawWidth = 1
      DrawPoly k, ScreenWidth / 2, ScreenHeight / 2, NominalSize

   End Select
Exit Sub

DrawBox:
   H = (j \ nSq) * SqWid
   V = (j Mod nSq) * SqHgt
   If Sparkles Then
      PolyForm.Line (H, V)-(H + SqWid, V + SqHgt), &HFFFFFF, BF
      DoEvents
   End If
   PolyForm.Line (H, V)-(H + SqWid, V + SqHgt), PolyForm.BackColor, BF
   Return
End Sub

Sub LoadINI ()
   Dim FName As String
   Dim OptBuff As String
   Dim Opt As String
   Dim R As Integer
   Dim D As Long

   EraseOptions(0) = 0
   EraseOptions(1) = 1
   EraseOptions(2) = 1
   EraseOptions(3) = 1
   EraseOptions(4) = 1
   EraseOptions(5) = 1
   EraseOptions(6) = 0

   EraseMinInterval = 10
   EraseMaxInterval = 25

   ThickOrder = 6
   DrawDelay = 0
   DrawSpeed = 0
   Sparkles = True

   OptBuff = String$(128, 0)
   FName = App.Path
   If Asc(Right$(FName, 1)) <> 92 Then
      FName = FName & "\"
   End If
   FName = FName & "PolyGone.Ini"

   If Dir$(FName$) = "" Then
      MsgBox ".INI File not found, will create at exit" + Chr$(13) + Chr$(10) + "Double-click on form for Parameters", 48, "PolyGone"
      Exit Sub
   Else
      Opt = OptBuff
      R = GetPrivateProfileString("Form", "State", "Normal", Opt, 128, FName)
      Opt = UCase$(Left$(Opt, 3))
      R = 0
      If Opt = "MIN" Then
         R = 1
      ElseIf Opt = "MAX" Then
         R = 2
      End If
      PolyForm.WindowState = R

      If R = 0 Then
         Opt = OptBuff
         R = GetPrivateProfileString("Form", "Top", "150", Opt, 128, FName)
         D = CLng(Left$(Opt, R))
         If D < 0 Then D = 0
         If D > Screen.Height Then D = Screen.Height - PolyForm.Height
         PolyForm.Top = D

         Opt = OptBuff
         R = GetPrivateProfileString("Form", "Left", "150", Opt, 128, FName)
         D = CLng(Left$(Opt, R))
         If D < 0 Then D = 0
         If D > Screen.Width Then D = Screen.Width - PolyForm.Width
         PolyForm.Left = D

         Opt = OptBuff
         R = GetPrivateProfileString("Form", "Height", "2250", Opt, 128, FName)
         D = CLng(Left$(Opt, R))
         If D < 700 Then D = 700
         If D > Screen.Height Then D = Screen.Height
         PolyForm.Height = D

         Opt = OptBuff
         R = GetPrivateProfileString("Form", "Width", "2460", Opt, 128, FName)
         D = CLng(Left$(Opt, R))
         If D < 400 Then D = 400
         If D > Screen.Width Then D = Screen.Width - PolyForm.Width
         PolyForm.Width = D
      End If

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "Snap", "False", Opt, 128, FName)
      EraseOptions(0) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "Tile", "True", Opt, 128, FName)
      EraseOptions(1) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "HSnake", "True", Opt, 128, FName)
      EraseOptions(2) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "VSnake", "True", Opt, 128, FName)
      EraseOptions(3) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "SpiralOut", "True", Opt, 128, FName)
      EraseOptions(4) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "SpiralIn", "True", Opt, 128, FName)
      EraseOptions(5) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "Zigzag", "True", Opt, 128, FName)
      EraseOptions(6) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "Sweep", "True", Opt, 128, FName)
      EraseOptions(7) = OptVal(Opt, R)

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "MinInterval", "10", Opt, 128, FName)
      D = Int(Val(Left$(Opt, R)))
      If D < 2 Then
         D = 1
      ElseIf D > 99 Then
         D = 99
      End If
      EraseMinInterval = D

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "MaxInterval", "25", Opt, 128, FName)
      D = Int(Val(Left$(Opt, R)))
      If D < 2 Then
         D = 2
      ElseIf D > 99 Then
         D = 99
      End If
      EraseMaxInterval = D

      Opt = OptBuff
      R = GetPrivateProfileString("Erase", "Sparkles", "True", Opt, 128, FName)
      Sparkles = Not (OptVal(Opt, R) = 0)

      Opt = OptBuff
      R = GetPrivateProfileString("Draw", "PolyDelay", "0", Opt, 128, FName)
      D = Int(Val(Left$(Opt, R)))
      If D < 0 Then
         D = 0
      ElseIf D > 99999 Then
         D = 99999
      End If
      DrawDelay = D

      Opt = OptBuff
      R = GetPrivateProfileString("Draw", "LineDelay", "0", Opt, 128, FName)
      D = Int(Val(Left$(Opt, R)))
      If D < 0 Then
         D = 0
      ElseIf D > 99999 Then
         D = 99999
      End If
      DrawSpeed = D

      Opt = OptBuff
      R = GetPrivateProfileString("Draw", "ThickBelow", "6", Opt, 128, FName)
      D = Int(Val(Left$(Opt, R)))
      If D < 0 Then
         D = 0
      ElseIf D > 99 Then
         D = 99
      End If
      ThickOrder = D

      Opt = OptBuff
      R = GetPrivateProfileString("Draw", "InOrder", "False", Opt, 128, FName)
      DrawInOrder = Not (OptVal(Opt, R) = 0)
   End If

End Sub

Sub Main ()

   Dim H, V, Size, SqSiz, Hb
   Dim Order As Integer
   Dim MaxOrder As Integer
   Dim MaxBump As Integer
   Dim Bump As Integer
   Dim Colr As Integer
   Dim PrevColr As Integer
   Dim tmp As Integer
   Dim Sq As Integer
   Dim D As Long

   LoadINI

   Randomize
   ScreenHeight = PolyForm.Height
   ScreenWidth = PolyForm.Width

   Ratio = 1            ' Aspect ratio, =1 for "square" pixels
   OnScreenCount = 0    ' number currently on screen
   Bump = 0             ' get more dense with age
   MaxBump = 10         ' but no more dense than this

   PolyForm.Show

   Do 'forever
      If CLSFlag Then ' if another process wants to CLS
         PolyForm.Cls
         CLSFlag = 0
         OnScreenCount = 0
         Bump = 0
      End If
      '
      ' Select a polygon "order" based on the current
      ' lowest and highest allowable values.  See
      ' Form_Resize for how Lowest and Highest are set
      '
      If PolyForm.WindowState <> 1 Then
         MaxOrder = LargestAllowed
      Else
         MaxOrder = LargestAllowed
      End If
      Order = Int(Rnd * (MaxOrder - SmallestAllowed + 1)) + SmallestAllowed
      '
      ' Choose a random color which
      ' isn't the current color
      '
ReColor:
      Do
         Colr% = Int(Rnd * 16)
      Loop While Abs(Colr% - PrevColr%) < 6
      '
      ' Don't allow BackColor unless the screen
      ' has at least 10 polygons already on it
      '
      If QBColor(Colr%) = PolyForm.BackColor Then
         If OnScreenCount < 10 Then
            GoTo ReColor
         End If
      End If
      PrevColr% = Colr%
      PolyForm.ForeColor = QBColor(Colr%)
      If OnScreenCount >= EraseMaxInterval Or Rnd > .9 Then
         '
         ' Every so often, erase the images.
         ' Force erasure when necessary...
         ' but only do that once there are at least
         ' some polygons already drawn.
         '
         If OnScreenCount >= EraseMinInterval Then
            tmp = Colr
            PolyForm.ForeColor = PolyForm.BackColor
            EraseForm
            PolyForm.Cls
            Colr = tmp
            If QBColor(Colr) = PolyForm.BackColor Then
               Colr = PrevColr
            End If
            PolyForm.ForeColor = QBColor(Colr)
            MaxOrder = LargestAllowed
            OnScreenCount = 0
            Bump = 0
         End If
      ElseIf Rnd > .05 Then
         '
         ' Most of the time (roughly 95%), choose
         ' a new size and position for the newest
         ' polygon.
         '
         Size = NominalSize / (((Rnd * 2.5) + 2) / 1.2)
         H = (Rnd * ScreenWidth)        ' keep the center
         V = (Rnd * ScreenHeight)       '    on the screen
         OnScreenCount = OnScreenCount + 1   ' count this one
         If Bump < MaxBump Then
            Bump = Bump + 1
         End If
      End If
      If Order <= ThickOrder Then
         PolyForm.DrawWidth = 2
      Else
         PolyForm.DrawWidth = 1
      End If
      '
      ' Now draw the polygon
      '
      Call DrawPoly(Order, H, V, Size)

      If DrawDelay > 0 Then
         For D& = 1 To DrawDelay
            DoEvents
         Next
      End If
   Loop
End Sub

Function OptVal% (OptStr As String, ByVal Length As Integer)
   OptStr = LCase$(Trim$(Left$(OptStr, Length)))
   Select Case OptStr
   Case "false", "no", "off"
      OptVal = 0
   Case "true", "yes", "on"
      OptVal = 1
   Case Else
      OptVal = 2
   End Select
End Function

Sub SaveINI ()
   Dim FName As String
   Dim Opt As String
   Dim R As Integer

   FName = App.Path
   If Asc(Right$(FName, 1)) <> 92 Then
      FName = FName & "\"
   End If
   FName = FName & "PolyGone.Ini"

   Select Case PolyForm.WindowState
   Case 0
      Opt = "Normal"
   Case 1
      Opt = "Minimized"
   Case 2
      Opt = "Maximized"
   End Select
   R = WritePrivateProfileString("Form", "State", Opt, FName)
   R = WritePrivateProfileString("Form", "Top", CStr(PolyForm.Top), FName)
   R = WritePrivateProfileString("Form", "Left", CStr(PolyForm.Left), FName)
   R = WritePrivateProfileString("Form", "Height", CStr(PolyForm.Height), FName)
   R = WritePrivateProfileString("Form", "Width", CStr(PolyForm.Width), FName)

   If EraseOptions(0) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "Snap", Opt, FName)

   If EraseOptions(1) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "Tile", Opt, FName)

   If EraseOptions(2) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "HSnake", Opt, FName)

   If EraseOptions(3) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "VSnake", Opt, FName)

   If EraseOptions(4) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "SpiralOut", Opt, FName)

   If EraseOptions(5) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "SpiralIn", Opt, FName)

   If EraseOptions(6) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "Zigzag", Opt, FName)

   If EraseOptions(7) = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "Sweep", Opt, FName)

   R = WritePrivateProfileString("Erase", "MinInterval", CStr(EraseMinInterval), FName)

   R = WritePrivateProfileString("Erase", "MaxInterval", CStr(EraseMaxInterval), FName)

   If Sparkles = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Erase", "Sparkles", Opt, FName)

   R = WritePrivateProfileString("Draw", "PolyDelay", CStr(DrawDelay), FName)

   R = WritePrivateProfileString("Draw", "LineDelay", CStr(DrawSpeed), FName)

   R = WritePrivateProfileString("Draw", "ThickBelow", CStr(ThickOrder), FName)

   If DrawInOrder = 0 Then
      Opt = "False"
   Else
      Opt = "True"
   End If
   R = WritePrivateProfileString("Draw", "InOrder", Opt, FName)

End Sub

Sub Shuffle (IAry() As Integer, iFlag As Integer)

' Randomize the order in which the vertices are accessed.
' IAry() is an array containing vertex numbers.

   Dim j As Integer
   Dim ku As Integer
   Dim kl As Integer
   Dim m As Integer
   Dim LastJ As Integer
   Dim tmp As Integer

   kl = LBound(IAry)
   ku = UBound(IAry)
   '
   ' Self-fill the array: I(9)=9, e.g.
   '
   For m% = kl To ku
      IAry(m%) = m%
   Next
   '
   ' Most of the time (about 90%), randomize the order
   ' in which the points will be accessed, but once
   ' in a while, let it happen in order.
   '
   If Not iFlag Then
      If Rnd > .1 Then
         LastJ% = -1
         For m% = kl To ku
            Do
               j% = Int(Rnd * ku) + kl
            Loop Until (j% <> m%) And (j% <> LastJ%)
            LastJ% = j%
            tmp = IAry(j%)
            IAry(j%) = IAry(m%)
            IAry(m%) = tmp
            DoEvents
         Next
      End If
   End If
End Sub

Sub SizeAdapt ()

   Dim tmp As Integer

   ScreenHeight = PolyForm.ScaleHeight
   ScreenWidth = PolyForm.ScaleWidth

   NominalSize = Sqr(ScreenWidth * ScreenHeight)

   SmallestAllowed = 3
   If PolyForm.WindowState = 1 Then 'if minimized, restrict range
      LargestAllowed = 12
   Else
      tmp = ScreenWidth
      If ScreenHeight < NominalSize Then
         tmp = ScreenHeight
      End If
      tmp = CInt(tmp / 900)
      If tmp < 5 Then
         tmp = 5
      End If
      LargestAllowed = (tmp * 3)
   End If
   EraseInit = True
   CLSFlag = True

End Sub